home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
eulisp
/
feel-075.lha
/
feel0.75
/
Src
/
streams.c
< prev
next >
Wrap
C/C++ Source or Header
|
1992-06-18
|
18KB
|
737 lines
/* ******************************************************************** */
/* streams.c Copyright (C) Codemist and University of Bath 1989 */
/* */
/* Stream handling */
/* ******************************************************************** */
/*
* Change Log:
* Version 1, May 1989
*/
#include <string.h>
#include <stdio.h>
#include "defs.h"
#include "structs.h"
#include "funcalls.h"
#include "error.h"
#include "global.h"
#include "modboot.h"
#include "symboot.h"
#include "ngenerics.h"
static LispObject sym_input;
static LispObject sym_output;
static LispObject sym_io;
static LispObject sym_character;
static LispObject sym_binary;
LispObject sym_append;
static LispObject sym_create;
static LispObject sym_overwrite;
static LispObject sym_new_version;
static LispObject sym_start;
static LispObject sym_end;
LispObject StdIn;
LispObject StdOut;
LispObject StdErr;
LispObject TraceOut;
LispObject DebugIO;
EUFUN_1( Fn_streamp, form)
{
return (is_stream(form) ? lisptrue : nil);
}
EUFUN_CLOSE
EUFUN_2( Fn_open, path, ops)
{
LispObject direction = NULL,mode = NULL;
int create = -1,append = -1;
LispObject walker,str;
FILE *fd;
char *way;
int retry_count = 0;
if (!is_string(path))
CallError(stacktop,"open: not a string",path,NONCONTINUABLE);
walker = ops;
while (is_cons(walker)) {
LispObject op;
op = CAR(walker); walker = CDR(walker);
if (!is_symbol(op))
CallError(stacktop,"open: invalid option",op,NONCONTINUABLE);
if (op == sym_input) {
if (direction != NULL)
CallError(stacktop,"open: exclusive options",ops,NONCONTINUABLE);
else
direction = op;
continue;
}
if (op == sym_output) {
if (direction != NULL)
CallError(stacktop,"open: exclusive options",ops,NONCONTINUABLE);
else
direction = op;
continue;
}
if (op == sym_io) {
if (direction != NULL)
CallError(stacktop,"open: exclusive options",ops,NONCONTINUABLE);
else
direction = op;
continue;
}
if (op == sym_character) {
if (mode != NULL)
CallError(stacktop,"open: exclusive options",ops,NONCONTINUABLE);
else
mode = op;
continue;
}
if (op == sym_binary) {
if (mode != NULL)
CallError(stacktop,"open: exclusive options",ops,NONCONTINUABLE);
else
CallError(stacktop,"open: binary mode unsupported",ops,NONCONTINUABLE);
continue;
}
if (op == sym_create) {
if (create != -1)
CallError(stacktop,"open: exclusive options",ops,NONCONTINUABLE);
else
create = TRUE;
continue;
}
if (op == sym_append) {
if (append != -1)
CallError(stacktop,"open: exclusive options",ops,NONCONTINUABLE);
else
append = TRUE;
continue;
}
if (op == sym_overwrite) {
if (append != -1)
CallError(stacktop,"open: exclusive options",ops,NONCONTINUABLE);
else
append = FALSE;
continue;
}
if (op == sym_new_version) {
CallError(stacktop,"open: new-version unsupported",ops,NONCONTINUABLE);
continue;
}
CallError(stacktop,"open: unrecognized option",op,NONCONTINUABLE);
}
if (direction == NULL) direction = sym_input;
if (mode == NULL) mode = sym_character;
if (create == -1) create = (direction == sym_io ? FALSE : TRUE);
if (append == -1) append = (direction == sym_io ? TRUE : FALSE);
if (direction == sym_input) {
way = "r";
fd = system_fopen(stringof(path),way);
if (fd == NULL)
CallError(stacktop,
"open: cannot open stream for reading",path,NONCONTINUABLE);
str = (LispObject) allocate_stream(stacktop,fd,way[0]);
return(str);
}
/* Potential output... */
if (direction == sym_output) {
if (append)
way = "a";
else
way = "w";
}
if (direction == sym_io) {
if (append)
way = "r+";
else
way = "w+";
}
retry:
fd = system_fopen(stringof(path),way);
if (fd == NULL) {
if (create && retry_count < 1) {
if ((fd = system_fopen(stringof(path),"w")) != NULL) {
fclose(fd);
goto retry;
}
}
CallError(stacktop,"open: cannot open stream for writing/update",
path,NONCONTINUABLE);
}
str = (LispObject) allocate_stream(stacktop,fd,way[0]);
return(str);
}
EUFUN_CLOSE
EUFUN_1( Fn_stream_position, str)
{
int ans;
if (!is_stream(str))
CallError(stacktop,"stream-position: not a stream",str,NONCONTINUABLE);
if (str->STREAM.handle == NULL)
CallError(stacktop,"stream-position: null stream",str,NONCONTINUABLE);
ans = (int) ftell(str->STREAM.handle);
if (ans == -1)
CallError(stacktop,
"stream-position: invalid-stream-position",str,NONCONTINUABLE);
return(allocate_integer(stacktop,ans));
}
EUFUN_CLOSE
EUFUN_2( Fn_stream_position_setter, str, n)
{
int end,pos;
if (!is_stream(str))
CallError(stacktop,
"(setter stream-position): not a stream",str,NONCONTINUABLE);
if (str->STREAM.handle == NULL)
CallError(stacktop,
"(setter stream-position): null stream",str,NONCONTINUABLE);
if (n == sym_start) {
end = 0; pos = 0;
}
else if (n == sym_end) {
end = 2; pos = 0;
}
else if (!is_fixnum(n))
signal_message(stacktop,INVALID_STREAM_POSITION,
"(setter stream_position): bad position",n);
else {
end = 0; pos = intval(n);
}
#ifdef WITH_FUDGE
{
extern void yy_reset_stream(FILE *);
yy_reset_stream(str->STREAM.handle);
}
#endif
if (fseek(str->STREAM.handle,pos,end) != 0L)
signal_message(stacktop,INVALID_STREAM_POSITION,
"(setter stream-position): seek failed",n);
return(n);
}
EUFUN_CLOSE
EUFUN_1( Fn_end_of_stream_p, obj)
{
return((obj == q_eof ? lisptrue : nil));
}
EUFUN_CLOSE
EUFUN_0( Fn_StdIn)
{
return StdIn;
}
EUFUN_CLOSE
EUFUN_1( Fn_SetStdIn, new)
{
while (!is_stream(new) || (new->STREAM).mode != 'r')
new = CallError(stacktop,"Not a stream in (set standard-input-stream)",
new,CONTINUABLE);
StdIn = new;
return nil;
}
EUFUN_CLOSE
EUFUN_0( Fn_StdOut)
{
return StdOut;
}
EUFUN_CLOSE
EUFUN_1( Fn_SetStdOut, new)
{
while (!is_stream(new) || (new->STREAM).mode == 'r')
new = CallError(stacktop,"Not a stream in (set standard-output-stream)",
new,CONTINUABLE);
StdOut = new;
return nil;
}
EUFUN_CLOSE
EUFUN_0( Fn_StdErr)
{
return StdErr;
}
EUFUN_CLOSE
EUFUN_1( Fn_SetStdErr, new)
{
while (!is_stream(new) || (new->STREAM).mode == 'r')
new = CallError(stacktop,"Not a stream in (set standard-error-stream)",
new,CONTINUABLE);
StdErr = new;
return nil;
}
EUFUN_CLOSE
EUFUN_0( Fn_TraceOut)
{
return TraceOut;
}
EUFUN_CLOSE
EUFUN_1( Fn_SetTraceOut, new)
{
while (!is_stream(new) || (new->STREAM).mode != 'r')
new = CallError(stacktop,"Not a stream in (set trace-output-stream)",
new,CONTINUABLE);
TraceOut = new;
return nil;
}
EUFUN_CLOSE
EUFUN_0( Fn_DebugIO)
{
return DebugIO;
}
EUFUN_CLOSE
EUFUN_1( Fn_SetDebugIO, new)
{
while (!is_stream(new) || (new->STREAM).mode != 'r')
new = CallError(stacktop,"Not a stream in (set debug-io-stream)",
new,CONTINUABLE);
DebugIO = new;
return nil;
}
EUFUN_CLOSE
EUFUN_1( Fn_close, stream)
{
while (!is_stream(stream))
stream = CallError(stacktop,"Not a Stream",stream,CONTINUABLE);
if (stream->STREAM.handle == NULL)
CallError(stacktop,"close: null stream",stream,NONCONTINUABLE);
#ifdef WITH_FUDGE
{
extern int yy_close_stream(FILE *);
(void) yy_close_stream(stream->STREAM.handle);
}
#else
system_fclose((stream->STREAM).handle);
#endif
(stream->STREAM).handle = NULL;
return nil;
}
EUFUN_CLOSE
EUFUN_1( Fn_flush, str)
{
if (!is_stream(str))
CallError(stacktop,"flush: not a stream",str,NONCONTINUABLE);
if (str->STREAM.handle == NULL)
CallError(stacktop,"flush: null stream",str,NONCONTINUABLE);
/*
if (str->STREAM.mode != (int) 'w' && str->STREAM.mode != (int) 'a')
CallError(stacktop,"flush: not an output stream",str,NONCONTINUABLE);
*/
fflush(str->STREAM.handle);
return(nil);
}
EUFUN_CLOSE
EUFUN_1( Fn_inputp, stream)
{
if (is_stream(stream) && (stream->STREAM).mode=='r') return lisptrue;
return nil;
}
EUFUN_CLOSE
EUFUN_1( Fn_outputp, stream)
{
if (is_stream(stream) && (stream->STREAM).mode!='r') return lisptrue;
return nil;
}
EUFUN_CLOSE
EUFUN_1( Fn_openp, stream)
{
if (is_stream(stream) && (stream->STREAM).handle!=NULL) return lisptrue;
return nil;
}
EUFUN_CLOSE
EUFUN_1( Fn_emptyp, stream)
{
if (is_stream(stream) && feof((stream->STREAM).handle)) return lisptrue;
return nil;
}
EUFUN_CLOSE
/* ******************************************************************** */
/* Generic Writing */
/* ******************************************************************** */
extern LispObject Fn_write(LispObject*);
LispObject generic_generic_write;
EUFUN_2( Gf_generic_write, obj, str)
{
return(generic_apply_2(stacktop,generic_generic_write,obj,str));
}
EUFUN_CLOSE
EUFUN_2( Md_generic_write_Object, obj, str)
{
if (!is_stream(str))
CallError(stacktop,"generic-write: invalid stream",str,NONCONTINUABLE);
return(EUCALL_2(Fn_write,obj,str));
}
EUFUN_CLOSE
/* ******************************************************************** */
/* Generic Printing */
/* ******************************************************************** */
LispObject generic_generic_prin;
EUFUN_2( Gf_generic_prin, obj, str)
{
return(generic_apply_2(stacktop,generic_generic_prin,obj,str));
}
EUFUN_CLOSE
EUFUN_2( Md_generic_prin_Object, obj, str)
{
if (!is_stream(str))
CallError(stacktop,"generic-prin: invalid stream",str,NONCONTINUABLE);
return(EUCALL_2(Fn_prin,obj,str));
}
EUFUN_CLOSE
EUFUN_2( Md_generic_prin_Pair, obj, str)
{
FILE *handle;
LispObject walker;
if (!is_stream(str))
CallError(stacktop,"generic-prin: invalid stream",str,NONCONTINUABLE);
handle = (FILE *) (str->STREAM.handle);
fprintf(handle,"(");
STACK(obj); STACK(str);
walker = obj;
while (is_cons(walker)) {
STACK_TMP(CDR(walker));
EUCALL_2(Gf_generic_prin,CAR(walker),ARG_1(stackbase));
UNSTACK_TMP(walker);
if (is_cons(walker)) fprintf(handle," ");
}
if (walker == nil)
fprintf(handle,")");
else {
fprintf(handle," . ");
EUCALL_2(Gf_generic_prin,walker,ARG_1(stackbase));
fprintf(handle,")");
}
UNSTACK(2);
return(ARG_0(stackbase));
}
EUFUN_CLOSE
EUFUN_2( FN_prin, obj, args)
{
EUCALL_2(Gf_generic_prin,obj,(is_cons(args) ? CAR(args) : StdOut));
return(ARG_0(stackbase));
}
EUFUN_CLOSE
EUFUN_1( FN_newline, str)
{
LispObject s;
if (str == nil)
s = StdOut;
else {
if (!is_cons(str))
CallError(stacktop,"newline: invalid stream",str,NONCONTINUABLE);
str = CAR(str);
if (!is_stream(str))
CallError(stacktop,"newline: invalid stream",str,NONCONTINUABLE);
s = str;
}
fprintf(s->STREAM.handle,"\n");
return(nil);
}
EUFUN_CLOSE
EUFUN_2( FN_print, obj, args)
{
LispObject str = (is_cons(args) ? CAR(args) : StdOut);
EUCALL_2(Gf_generic_prin,obj,str);
EUCALL_1(FN_newline,ARG_1(stackbase)/*args*/);
return(ARG_0(stackbase));
}
EUFUN_CLOSE
EUFUN_2( FN_write, obj, args)
{
EUCALL_2(Gf_generic_write,obj,(is_cons(args) ? CAR(args) : StdOut));
return(ARG_0(stackbase));
}
EUFUN_CLOSE
/*
* Hack at "popen"...
*/
EUFUN_2( Fn_popen, path, mode)
{
#ifdef HAS_POPEN
extern FILE *popen(char *,char *);
LispObject retval;
char *cmode;
FILE *cstream;
if (!is_string(path))
CallError(stacktop,"popen: non string path",path,NONCONTINUABLE);
if (mode == sym_input) {
cmode = "r";
}
else if (mode == sym_output) {
cmode = "w";
}
else
CallError(stacktop,"popen: unknown mode",mode,NONCONTINUABLE);
/* Open it up... */
cstream = popen(stringof(path),cmode);
if (cstream == NULL)
CallError(stacktop,"popen: can't execute command",path,NONCONTINUABLE);
/* Grab a stream... */
retval = allocate_stream(stacktop,cstream,cmode[0]);
return(retval);
#else
CallError(stacktop,"popen called",nil,NONCONTINUABLE);
return (nil);
#endif
}
EUFUN_CLOSE
LispObject X_Server_Handle;
/* *************************************************************** */
/* Initialisation of this section */
/* *************************************************************** */
#define STREAMS_ENTRIES 43
MODULE Module_streams;
LispObject Module_streams_values[STREAMS_ENTRIES];
void initialise_streams(LispObject *stacktop)
{
LispObject fun,upd;
open_module(stacktop,
&Module_streams,
Module_streams_values,
"streams",
STREAMS_ENTRIES);
sym_input = (LispObject) get_symbol(stacktop,"input");
sym_output = (LispObject) get_symbol(stacktop,"output");
sym_io = (LispObject) get_symbol(stacktop,"io");
sym_character = (LispObject) get_symbol(stacktop,"character");
sym_binary = get_symbol(stacktop,"binary");
sym_append = (LispObject) get_symbol(stacktop,"append");
sym_create = get_symbol(stacktop,"create");
sym_overwrite = get_symbol(stacktop,"overwrite");
sym_new_version = get_symbol(stacktop,"new-version");
sym_start = get_symbol(stacktop,"start");
sym_end = get_symbol(stacktop,"end");
add_root(&sym_input);
add_root(& sym_output);
add_root(& sym_io);
add_root(& sym_character);
add_root(& sym_binary);
add_root(& sym_append);
add_root(& sym_create);
add_root(& sym_overwrite);
add_root(& sym_new_version);
add_root(& sym_start);
add_root(& sym_end);
initialise_input(stacktop);
initialise_output(stacktop);
(void) make_module_entry(stacktop,"*eos*",q_eof);
(void) make_module_function(stacktop,"streamp",Fn_streamp,1);
(void) make_module_function(stacktop,"open",Fn_open,-2);
fun = make_module_function(stacktop,"stream-position",Fn_stream_position,1);
STACK_TMP(fun);
upd = make_unexported_module_function(stacktop,"stream_position_setter",
Fn_stream_position_setter,2);
UNSTACK_TMP(fun);
set_anon_associate(stacktop,fun,upd);
(void) make_module_function(stacktop,"end-of-stream-p",Fn_end_of_stream_p,1);
fun = make_module_function(stacktop,"standard-input-stream",Fn_StdIn,0);
STACK_TMP(fun);
upd = make_module_function(stacktop,"standard-input-stream-updator", Fn_SetStdIn,1);
UNSTACK_TMP(fun);
set_anon_associate(stacktop,fun,upd);
fun = make_module_function(stacktop,"standard-output-stream",Fn_StdOut,0);
STACK_TMP(fun);
upd = make_module_function(stacktop,"standard-output-stream-updator",Fn_SetStdOut,1);
UNSTACK_TMP(fun);
set_anon_associate(stacktop,fun,upd);
fun = make_module_function(stacktop,"standard-error-stream",Fn_StdErr,0);
STACK_TMP(fun);
upd = make_module_function(stacktop,"standard-error-stream-updator",Fn_SetStdErr,1);
UNSTACK_TMP(fun);
set_anon_associate(stacktop,fun,upd);
fun = make_module_function(stacktop,"trace-output-stream",Fn_TraceOut,0);
STACK_TMP(fun);
upd = make_module_function(stacktop,"trace-output-stream-updator",Fn_SetTraceOut,1);
UNSTACK_TMP(fun);
set_anon_associate(stacktop,fun,upd);
fun = make_module_function(stacktop,"debug-io-stream",Fn_DebugIO,0);
STACK_TMP(fun);
upd = make_module_function(stacktop,"debug-io-stream-updator",Fn_SetDebugIO,1);
UNSTACK_TMP(fun);
set_anon_associate(stacktop,fun,upd);
StdIn = (LispObject) allocate_stream(stacktop,stdin,'r');
add_root(&StdIn);
StdOut = (LispObject) allocate_stream(stacktop,stdout,'a');
add_root(&StdOut);
StdErr = (LispObject) allocate_stream(stacktop,stderr,'a');
add_root(&StdErr);
TraceOut = StdErr;
add_root(&TraceOut);
DebugIO = StdErr;
add_root(&DebugIO);
(void) make_module_function(stacktop,"close",Fn_close,1);
(void) make_module_function(stacktop,"flush",Fn_flush,1);
(void) make_module_function(stacktop,"input-stream-p",Fn_inputp,1);
(void) make_module_function(stacktop,"output-stream-p",Fn_outputp,1);
(void) make_module_function(stacktop,"open-stream-p",Fn_openp,1);
(void) make_module_function(stacktop,"empty-stream-p",Fn_emptyp,1);
generic_generic_write
= make_wrapped_module_generic(stacktop,"generic-write",2,Gf_generic_write);
add_root(&generic_generic_write);
(void) make_module_function(stacktop,"generic_generic_write,Object",
Md_generic_write_Object,2);
generic_generic_prin
= make_wrapped_module_generic(stacktop,"generic-prin",2,Gf_generic_prin);
add_root(&generic_generic_prin);
(void) make_module_function(stacktop,"generic_generic_prin,Object",
Md_generic_prin_Object,2);
(void) make_module_function(stacktop,"generic_generic_prin,Cons",
Md_generic_prin_Pair,2);
(void) make_module_function(stacktop,"prin",FN_prin,-2);
(void) make_module_function(stacktop,"write",FN_write,-2);
(void) make_module_function(stacktop,"newline",FN_newline,-1);
(void) make_module_function(stacktop,"print",FN_print,-2);
(void) make_module_function(stacktop,"popen",Fn_popen,2);
{
extern int command_line_window_flag;
FILE *handle;
#ifdef HAS_POPEN
FILE *popen(char *,char *);
if (command_line_window_flag) {
handle = popen("xserver -rv 500 500","w");
fprintf(handle,"7 210 10 EuLisp FEEL\n"); fflush(handle);
X_Server_Handle = (LispObject) allocate_stream(stacktop,handle,'w');
}
else
X_Server_Handle = StdOut;
#else
X_Server_Handle = StdOut;
#endif
add_root(&X_Server_Handle);
make_module_entry(stacktop,"X-stream",X_Server_Handle);
}
close_module();
}